home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / Net / HTTP / Methods.pm next >
Encoding:
Perl POD Document  |  2008-10-20  |  13.5 KB  |  559 lines
  1. package Net::HTTP::Methods;
  2.  
  3. require 5.005;  # 4-arg substr
  4.  
  5. use strict;
  6. use vars qw($VERSION);
  7.  
  8. $VERSION = "5.815";
  9.  
  10. my $CRLF = "\015\012";   # "\r\n" is not portable
  11.  
  12. sub new {
  13.     my $class = shift;
  14.     unshift(@_, "Host") if @_ == 1;
  15.     my %cnf = @_;
  16.     require Symbol;
  17.     my $self = bless Symbol::gensym(), $class;
  18.     return $self->http_configure(\%cnf);
  19. }
  20.  
  21. sub http_configure {
  22.     my($self, $cnf) = @_;
  23.  
  24.     die "Listen option not allowed" if $cnf->{Listen};
  25.     my $explict_host = (exists $cnf->{Host});
  26.     my $host = delete $cnf->{Host};
  27.     my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
  28.     if (!$peer) {
  29.     die "No Host option provided" unless $host;
  30.     $cnf->{PeerAddr} = $peer = $host;
  31.     }
  32.  
  33.     if ($peer =~ s,:(\d+)$,,) {
  34.     $cnf->{PeerPort} = int($1);  # always override
  35.     }
  36.     if (!$cnf->{PeerPort}) {
  37.     $cnf->{PeerPort} = $self->http_default_port;
  38.     }
  39.  
  40.     if (!$explict_host) {
  41.     $host = $peer;
  42.     $host =~ s/:.*//;
  43.     }
  44.     if ($host && $host !~ /:/) {
  45.     my $p = $cnf->{PeerPort};
  46.     $host .= ":$p" if $p != $self->http_default_port;
  47.     }
  48.  
  49.     $cnf->{Proto} = 'tcp';
  50.  
  51.     my $keep_alive = delete $cnf->{KeepAlive};
  52.     my $http_version = delete $cnf->{HTTPVersion};
  53.     $http_version = "1.1" unless defined $http_version;
  54.     my $peer_http_version = delete $cnf->{PeerHTTPVersion};
  55.     $peer_http_version = "1.0" unless defined $peer_http_version;
  56.     my $send_te = delete $cnf->{SendTE};
  57.     my $max_line_length = delete $cnf->{MaxLineLength};
  58.     $max_line_length = 4*1024 unless defined $max_line_length;
  59.     my $max_header_lines = delete $cnf->{MaxHeaderLines};
  60.     $max_header_lines = 128 unless defined $max_header_lines;
  61.  
  62.     return undef unless $self->http_connect($cnf);
  63.  
  64.     $self->host($host);
  65.     $self->keep_alive($keep_alive);
  66.     $self->send_te($send_te);
  67.     $self->http_version($http_version);
  68.     $self->peer_http_version($peer_http_version);
  69.     $self->max_line_length($max_line_length);
  70.     $self->max_header_lines($max_header_lines);
  71.  
  72.     ${*$self}{'http_buf'} = "";
  73.  
  74.     return $self;
  75. }
  76.  
  77. sub http_default_port {
  78.     80;
  79. }
  80.  
  81. # set up property accessors
  82. for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
  83.     my $prop_name = "http_" . $method;
  84.     no strict 'refs';
  85.     *$method = sub {
  86.     my $self = shift;
  87.     my $old = ${*$self}{$prop_name};
  88.     ${*$self}{$prop_name} = shift if @_;
  89.     return $old;
  90.     };
  91. }
  92.  
  93. # we want this one to be a bit smarter
  94. sub http_version {
  95.     my $self = shift;
  96.     my $old = ${*$self}{'http_version'};
  97.     if (@_) {
  98.     my $v = shift;
  99.     $v = "1.0" if $v eq "1";  # float
  100.     unless ($v eq "1.0" or $v eq "1.1") {
  101.         require Carp;
  102.         Carp::croak("Unsupported HTTP version '$v'");
  103.     }
  104.     ${*$self}{'http_version'} = $v;
  105.     }
  106.     $old;
  107. }
  108.  
  109. sub format_request {
  110.     my $self = shift;
  111.     my $method = shift;
  112.     my $uri = shift;
  113.  
  114.     my $content = (@_ % 2) ? pop : "";
  115.  
  116.     for ($method, $uri) {
  117.     require Carp;
  118.     Carp::croak("Bad method or uri") if /\s/ || !length;
  119.     }
  120.  
  121.     push(@{${*$self}{'http_request_method'}}, $method);
  122.     my $ver = ${*$self}{'http_version'};
  123.     my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
  124.  
  125.     my @h;
  126.     my @connection;
  127.     my %given = (host => 0, "content-length" => 0, "te" => 0);
  128.     while (@_) {
  129.     my($k, $v) = splice(@_, 0, 2);
  130.     my $lc_k = lc($k);
  131.     if ($lc_k eq "connection") {
  132.         $v =~ s/^\s+//;
  133.         $v =~ s/\s+$//;
  134.         push(@connection, split(/\s*,\s*/, $v));
  135.         next;
  136.     }
  137.     if (exists $given{$lc_k}) {
  138.         $given{$lc_k}++;
  139.     }
  140.     push(@h, "$k: $v");
  141.     }
  142.  
  143.     if (length($content) && !$given{'content-length'}) {
  144.     push(@h, "Content-Length: " . length($content));
  145.     }
  146.  
  147.     my @h2;
  148.     if ($given{te}) {
  149.     push(@connection, "TE") unless grep lc($_) eq "te", @connection;
  150.     }
  151.     elsif ($self->send_te && zlib_ok()) {
  152.     # gzip is less wanted since the Compress::Zlib interface for
  153.     # it does not really allow chunked decoding to take place easily.
  154.     push(@h2, "TE: deflate,gzip;q=0.3");
  155.     push(@connection, "TE");
  156.     }
  157.  
  158.     unless (grep lc($_) eq "close", @connection) {
  159.     if ($self->keep_alive) {
  160.         if ($peer_ver eq "1.0") {
  161.         # from looking at Netscape's headers
  162.         push(@h2, "Keep-Alive: 300");
  163.         unshift(@connection, "Keep-Alive");
  164.         }
  165.     }
  166.     else {
  167.         push(@connection, "close") if $ver ge "1.1";
  168.     }
  169.     }
  170.     push(@h2, "Connection: " . join(", ", @connection)) if @connection;
  171.     unless ($given{host}) {
  172.     my $h = ${*$self}{'http_host'};
  173.     push(@h2, "Host: $h") if $h;
  174.     }
  175.  
  176.     return join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content);
  177. }
  178.  
  179.  
  180. sub write_request {
  181.     my $self = shift;
  182.     $self->print($self->format_request(@_));
  183. }
  184.  
  185. sub format_chunk {
  186.     my $self = shift;
  187.     return $_[0] unless defined($_[0]) && length($_[0]);
  188.     return sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF;
  189. }
  190.  
  191. sub write_chunk {
  192.     my $self = shift;
  193.     return 1 unless defined($_[0]) && length($_[0]);
  194.     $self->print(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF);
  195. }
  196.  
  197. sub format_chunk_eof {
  198.     my $self = shift;
  199.     my @h;
  200.     while (@_) {
  201.     push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
  202.     }
  203.     return join("", "0$CRLF", @h, $CRLF);
  204. }
  205.  
  206. sub write_chunk_eof {
  207.     my $self = shift;
  208.     $self->print($self->format_chunk_eof(@_));
  209. }
  210.  
  211.  
  212. sub my_read {
  213.     die if @_ > 3;
  214.     my $self = shift;
  215.     my $len = $_[1];
  216.     for (${*$self}{'http_buf'}) {
  217.     if (length) {
  218.         $_[0] = substr($_, 0, $len, "");
  219.         return length($_[0]);
  220.     }
  221.     else {
  222.         return $self->sysread($_[0], $len);
  223.     }
  224.     }
  225. }
  226.  
  227.  
  228. sub my_readline {
  229.     my $self = shift;
  230.     for (${*$self}{'http_buf'}) {
  231.     my $max_line_length = ${*$self}{'http_max_line_length'};
  232.     my $pos;
  233.     while (1) {
  234.         # find line ending
  235.         $pos = index($_, "\012");
  236.         last if $pos >= 0;
  237.         die "Line too long (limit is $max_line_length)"
  238.         if $max_line_length && length($_) > $max_line_length;
  239.  
  240.         # need to read more data to find a line ending
  241.           READ:
  242.             {
  243.                 my $n = $self->sysread($_, 1024, length);
  244.                 unless (defined $n) {
  245.                     redo READ if $!{EINTR};
  246.                     if ($!{EAGAIN}) {
  247.                         # Hmm, we must be reading from a non-blocking socket
  248.                         # XXX Should really wait until this socket is readable,...
  249.                         select(undef, undef, undef, 0.1);  # but this will do for now
  250.                         redo READ;
  251.                     }
  252.                     # if we have already accumulated some data let's at least
  253.                     # return that as a line
  254.                     die "read failed: $!" unless length;
  255.                 }
  256.                 unless ($n) {
  257.                     return undef unless length;
  258.                     return substr($_, 0, length, "");
  259.                 }
  260.             }
  261.     }
  262.     die "Line too long ($pos; limit is $max_line_length)"
  263.         if $max_line_length && $pos > $max_line_length;
  264.  
  265.     my $line = substr($_, 0, $pos+1, "");
  266.     $line =~ s/(\015?\012)\z// || die "Assert";
  267.     return wantarray ? ($line, $1) : $line;
  268.     }
  269. }
  270.  
  271.  
  272. sub _rbuf {
  273.     my $self = shift;
  274.     if (@_) {
  275.     for (${*$self}{'http_buf'}) {
  276.         my $old;
  277.         $old = $_ if defined wantarray;
  278.         $_ = shift;
  279.         return $old;
  280.     }
  281.     }
  282.     else {
  283.     return ${*$self}{'http_buf'};
  284.     }
  285. }
  286.  
  287. sub _rbuf_length {
  288.     my $self = shift;
  289.     return length ${*$self}{'http_buf'};
  290. }
  291.  
  292.  
  293. sub _read_header_lines {
  294.     my $self = shift;
  295.     my $junk_out = shift;
  296.  
  297.     my @headers;
  298.     my $line_count = 0;
  299.     my $max_header_lines = ${*$self}{'http_max_header_lines'};
  300.     while (my $line = my_readline($self)) {
  301.     if ($line =~ /^(\S+?)\s*:\s*(.*)/s) {
  302.         push(@headers, $1, $2);
  303.     }
  304.     elsif (@headers && $line =~ s/^\s+//) {
  305.         $headers[-1] .= " " . $line;
  306.     }
  307.     elsif ($junk_out) {
  308.         push(@$junk_out, $line);
  309.     }
  310.     else {
  311.         die "Bad header: '$line'\n";
  312.     }
  313.     if ($max_header_lines) {
  314.         $line_count++;
  315.         if ($line_count >= $max_header_lines) {
  316.         die "Too many header lines (limit is $max_header_lines)";
  317.         }
  318.     }
  319.     }
  320.     return @headers;
  321. }
  322.  
  323.  
  324. sub read_response_headers {
  325.     my($self, %opt) = @_;
  326.     my $laxed = $opt{laxed};
  327.  
  328.     my($status, $eol) = my_readline($self);
  329.     unless (defined $status) {
  330.     die "Server closed connection without sending any data back";
  331.     }
  332.  
  333.     my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
  334.     if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) {
  335.     die "Bad response status line: '$status'" unless $laxed;
  336.     # assume HTTP/0.9
  337.     ${*$self}{'http_peer_http_version'} = "0.9";
  338.     ${*$self}{'http_status'} = "200";
  339.     substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || "");
  340.     return 200 unless wantarray;
  341.     return (200, "Assumed OK");
  342.     };
  343.  
  344.     ${*$self}{'http_peer_http_version'} = $peer_ver;
  345.     ${*$self}{'http_status'} = $code;
  346.  
  347.     my $junk_out;
  348.     if ($laxed) {
  349.     $junk_out = $opt{junk_out} || [];
  350.     }
  351.     my @headers = $self->_read_header_lines($junk_out);
  352.  
  353.     # pick out headers that read_entity_body might need
  354.     my @te;
  355.     my $content_length;
  356.     for (my $i = 0; $i < @headers; $i += 2) {
  357.     my $h = lc($headers[$i]);
  358.     if ($h eq 'transfer-encoding') {
  359.         my $te = $headers[$i+1];
  360.         $te =~ s/^\s+//;
  361.         $te =~ s/\s+$//;
  362.         push(@te, $te) if length($te);
  363.     }
  364.     elsif ($h eq 'content-length') {
  365.         # ignore bogus and overflow values
  366.         if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) {
  367.         $content_length = $1;
  368.         }
  369.     }
  370.     }
  371.     ${*$self}{'http_te'} = join(",", @te);
  372.     ${*$self}{'http_content_length'} = $content_length;
  373.     ${*$self}{'http_first_body'}++;
  374.     delete ${*$self}{'http_trailers'};
  375.     return $code unless wantarray;
  376.     return ($code, $message, @headers);
  377. }
  378.  
  379.  
  380. sub read_entity_body {
  381.     my $self = shift;
  382.     my $buf_ref = \$_[0];
  383.     my $size = $_[1];
  384.     die "Offset not supported yet" if $_[2];
  385.  
  386.     my $chunked;
  387.     my $bytes;
  388.  
  389.     if (${*$self}{'http_first_body'}) {
  390.     ${*$self}{'http_first_body'} = 0;
  391.     delete ${*$self}{'http_chunked'};
  392.     delete ${*$self}{'http_bytes'};
  393.     my $method = shift(@{${*$self}{'http_request_method'}});
  394.     my $status = ${*$self}{'http_status'};
  395.     if ($method eq "HEAD") {
  396.         # this response is always empty regardless of other headers
  397.         $bytes = 0;
  398.     }
  399.     elsif (my $te = ${*$self}{'http_te'}) {
  400.         my @te = split(/\s*,\s*/, lc($te));
  401.         die "Chunked must be last Transfer-Encoding '$te'"
  402.         unless pop(@te) eq "chunked";
  403.  
  404.         for (@te) {
  405.         if ($_ eq "deflate" && zlib_ok()) {
  406.             #require Compress::Zlib;
  407.             my $i = Compress::Zlib::inflateInit();
  408.             die "Can't make inflator" unless $i;
  409.             $_ = sub { scalar($i->inflate($_[0])) }
  410.         }
  411.         elsif ($_ eq "gzip" && zlib_ok()) {
  412.             #require Compress::Zlib;
  413.             my @buf;
  414.             $_ = sub {
  415.             push(@buf, $_[0]);
  416.             return Compress::Zlib::memGunzip(join("", @buf)) if $_[1];
  417.             return "";
  418.             };
  419.         }
  420.         elsif ($_ eq "identity") {
  421.             $_ = sub { $_[0] };
  422.         }
  423.         else {
  424.             die "Can't handle transfer encoding '$te'";
  425.         }
  426.         }
  427.  
  428.         @te = reverse(@te);
  429.  
  430.         ${*$self}{'http_te2'} = @te ? \@te : "";
  431.         $chunked = -1;
  432.     }
  433.     elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
  434.         $bytes = $content_length;
  435.     }
  436.         elsif ($status =~ /^(?:1|[23]04)/) {
  437.             # RFC 2616 says that these responses should always be empty
  438.             # but that does not appear to be true in practice [RT#17907]
  439.             $bytes = 0;
  440.         }
  441.     else {
  442.         # XXX Multi-Part types are self delimiting, but RFC 2616 says we
  443.         # only has to deal with 'multipart/byteranges'
  444.  
  445.         # Read until EOF
  446.     }
  447.     }
  448.     else {
  449.     $chunked = ${*$self}{'http_chunked'};
  450.     $bytes   = ${*$self}{'http_bytes'};
  451.     }
  452.  
  453.     if (defined $chunked) {
  454.     # The state encoded in $chunked is:
  455.     #   $chunked == 0:   read CRLF after chunk, then chunk header
  456.         #   $chunked == -1:  read chunk header
  457.     #   $chunked > 0:    bytes left in current chunk to read
  458.  
  459.     if ($chunked <= 0) {
  460.         my $line = my_readline($self);
  461.         if ($chunked == 0) {
  462.         die "Missing newline after chunk data: '$line'"
  463.             if !defined($line) || $line ne "";
  464.         $line = my_readline($self);
  465.         }
  466.         die "EOF when chunk header expected" unless defined($line);
  467.         my $chunk_len = $line;
  468.         $chunk_len =~ s/;.*//;  # ignore potential chunk parameters
  469.         unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) {
  470.         die "Bad chunk-size in HTTP response: $line";
  471.         }
  472.         $chunked = hex($1);
  473.         if ($chunked == 0) {
  474.         ${*$self}{'http_trailers'} = [$self->_read_header_lines];
  475.         $$buf_ref = "";
  476.  
  477.         my $n = 0;
  478.         if (my $transforms = delete ${*$self}{'http_te2'}) {
  479.             for (@$transforms) {
  480.             $$buf_ref = &$_($$buf_ref, 1);
  481.             }
  482.             $n = length($$buf_ref);
  483.         }
  484.  
  485.         # in case somebody tries to read more, make sure we continue
  486.         # to return EOF
  487.         delete ${*$self}{'http_chunked'};
  488.         ${*$self}{'http_bytes'} = 0;
  489.  
  490.         return $n;
  491.         }
  492.     }
  493.  
  494.     my $n = $chunked;
  495.     $n = $size if $size && $size < $n;
  496.     $n = my_read($self, $$buf_ref, $n);
  497.     return undef unless defined $n;
  498.  
  499.     ${*$self}{'http_chunked'} = $chunked - $n;
  500.  
  501.     if ($n > 0) {
  502.         if (my $transforms = ${*$self}{'http_te2'}) {
  503.         for (@$transforms) {
  504.             $$buf_ref = &$_($$buf_ref, 0);
  505.         }
  506.         $n = length($$buf_ref);
  507.         $n = -1 if $n == 0;
  508.         }
  509.     }
  510.     return $n;
  511.     }
  512.     elsif (defined $bytes) {
  513.     unless ($bytes) {
  514.         $$buf_ref = "";
  515.         return 0;
  516.     }
  517.     my $n = $bytes;
  518.     $n = $size if $size && $size < $n;
  519.     $n = my_read($self, $$buf_ref, $n);
  520.     return undef unless defined $n;
  521.     ${*$self}{'http_bytes'} = $bytes - $n;
  522.     return $n;
  523.     }
  524.     else {
  525.     # read until eof
  526.     $size ||= 8*1024;
  527.     return my_read($self, $$buf_ref, $size);
  528.     }
  529. }
  530.  
  531. sub get_trailers {
  532.     my $self = shift;
  533.     @{${*$self}{'http_trailers'} || []};
  534. }
  535.  
  536. BEGIN {
  537. my $zlib_ok;
  538.  
  539. sub zlib_ok {
  540.     return $zlib_ok if defined $zlib_ok;
  541.  
  542.     # Try to load Compress::Zlib.
  543.     local $@;
  544.     local $SIG{__DIE__};
  545.     $zlib_ok = 0;
  546.  
  547.     eval {
  548.     require Compress::Zlib;
  549.     Compress::Zlib->VERSION(1.10);
  550.     $zlib_ok++;
  551.     };
  552.  
  553.     return $zlib_ok;
  554. }
  555.  
  556. } # BEGIN
  557.  
  558. 1;
  559.